Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyListWindow.p

Text File | 1997-03-18 | 21KB | 819 lines

unit MyListWindow;

interface

    uses
        Types, Events, Lists, Drag, Controls, Quickdraw,
        MyOOMainLoop;

    type
        ListWindowObject = object(DObject)
                list: ListHandle;
                hcontrol: ControlHandle;
                list_offset, list_width, max_display_width, header_height: integer;
                typed_chars: Str31;
                typed_time: longint;
                never_drag: boolean;
                list_item: integer;
                procedure CreateList (font, size: integer; listitem: integer; ldefID: integer; hscroll: boolean);
                procedure Destroy;
                override;
                procedure DoItemWhere (const er: EventRecord; item: integer);
                override;
                procedure Resize;
                override;
                procedure DrawGrow;
                override;
                procedure DoActivateDeactivate (activate: boolean);
                override;
                procedure DoKey (const er:EventRecord; ch: char);
                override;
                function Match (c: Cell; var what: Str255): boolean;
                procedure Find (what: Str255; fromstart, allatonce, backwards: boolean);
                procedure AdjustHContol (canRedraw: BOOLEAN);
                procedure SetListWidth (max: integer);
                procedure UpdateZoomHeight;
                function DontDrag (er: EventRecord): boolean;
                function DoLClick (er: EventRecord): boolean;
                procedure DoDoubleClick;
                procedure DoDoubleClickCell (c: Cell);
                function GetEntryName (c: Cell): Str255;
                function GetUniqueEntryName (c: Cell): Str255;
                procedure OpenParent;
                procedure LDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataOffset, dataLen: integer);
                procedure DrawHeader (r: Rect);
                procedure DoHeaderClick (r: Rect; where: Point; const er: EventRecord );
                procedure SetSingleSelection (v: integer);
                function SelectFirstAfter (s: Str255): boolean;
                function SelectFirstBefore (s: Str255): boolean;
                function GetFirstSelection (var c: Cell): boolean;
                function GetLastSelection (var c: Cell): boolean;
                function CountSelections: integer;
                function IsSelection: boolean;
                function DoSetupDragCell (c: Cell; dragref: DragReference; dragrgn: RgnHandle): OSErr;
                function DoSetupDrag (dragref: DragReference; dragrgn: RgnHandle): OSErr;
                override;
                procedure RedrawLine( line: integer );
                procedure DrawUserItem( item: integer );
                override;
            end;

    procedure StartupMyListWindow;

implementation

    uses
        ToolUtils, Drag, Dialogs, OSUtils, QuickdrawText, TextUtils, Windows,
        MyDialogs, MyAssertions, MyStartup, MyTypes, MyMathUtils,
        MySystemGlobals, MyListManager, MyCursors, MyCallProc,
        SmartScrollAPI;

{$ifc do_debug}
    var
        startup_check: integer;
{$endc}

    var
        gCallLDEFProc : UniversalProcPtr;
        gHActionProc : UniversalProcPtr;

    procedure ListWindowObject.DrawUserItem( item: integer );
        var
            list_rect, header_rect: Rect;
    begin
        SetPort( window );
        if item = list_item then begin
            PenNormal;
            GetDItemRect( window, item, list_rect );
            header_rect := list_rect;
            list_rect.top := list_rect.top + Choose( header_height > 0, header_height + 1, 0);
            InsetRect( list_rect, -1, -1 );
            FrameRect( list_rect );
            if header_height > 0 then begin
                header_rect.bottom := header_rect.top + header_height;
                DrawHeader( header_rect );
            end;
            DrawGrow;
            LUpdate( window^.visRgn, list );
        end else begin
            inherited DrawUserItem( item );
        end;
    end;

    function ListWindowObject.Match (c: Cell; var what: Str255): boolean;
    begin
{$unused(c, what)}
        Match := false;
    end;

    procedure ListWindowObject.Find (what: Str255; fromstart, allatonce, backwards: boolean);
        var
            c: Cell;
            found, found1: boolean;
    begin
        if allatonce then begin
            found := false;
            c.v := 0;
            c.h := 0;
            while (c.v < LCount( list )) do begin
                found1 := Match(c, what);
                LSetSelect(found1, c, list);
                if found1 then begin
                    found := true;
                end;
                c.v := c.v + 1;
            end;
        end else begin
            if backwards then begin
                if fromstart then begin
                    c.v := LCount( list )-1;
                    c.h := 0;
                end else begin
                    c.v := 0;
                    c.h := 0;
                    if LGetSelect(true, c, list) then begin
                        c.v:=c.v-1;
                    end else begin
                        c.v := LCount( list )-1;
                        c.h := 0;
                    end;
                end;
                found := false;
                while (c.v >=0) do begin
                    found := Match(c, what);
                    if found then begin
                        leave;
                    end;
                    c.v := c.v - 1;
                end;
            end else begin
                c.v := 0;
                c.h := 0;
                if not fromstart then begin
                    while LGetSelect(true, c, list) do begin
                        c.v := c.v + 1;
                        c.h := 0;
                    end;
                end;
                found := false;
                while (c.v < LCount( list )) do begin
                    found := Match(c, what);
                    if found then begin
                        leave;
                    end;
                    c.v := c.v + 1;
                end;
            end;
            if found then begin
                SetSingleSelection(c.v);
            end;
        end;
        if not found then begin
            SysBeep(1);
        end;
    end;

    procedure ListWindowObject.LDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataOffset, dataLen: integer);
    begin
{$unused(message, select, r, c, dataOffset, dataLen)}
    end;

    procedure ListWindowObject.DrawHeader (r: Rect);
    begin
{$unused(r)}
    end;

    procedure ListWindowObject.DoHeaderClick (r: Rect; where: Point; const er: EventRecord );
    begin
{$unused(r, where, er)}
    end;

    procedure CallLDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataOffset, dataLen: integer; lh: ListHandle);
        var
            obj:WObject; { BUG IN MWP }
    begin
        obj:=GetWObject(lh^^.port);
        ListWindowObject(obj).LDEF(message, select, r, c, dataOffset, dataLen);
    end;

    procedure ListWindowObject.SetListWidth (max: integer);
    begin
        list_width := max;
        zoomSize.h := max + 16;
        UpdateZoomHeight;
        AdjustHContol(true);
    end;

    procedure ListWindowObject.UpdateZoomHeight;
        var
            zv: longint;
    begin
        zv := longint(list^^.cellSize.v) * longint(LCount( list )) + 16 + header_height;
        if zv > 30000 then begin
            zoomSize.v := 30000;
        end else begin
            zoomSize.v := zv;
        end;
    end;

    procedure ListWindowObject.AdjustHContol (canRedraw: BOOLEAN);
{Calculate the new control maximum value and current value }
{max is calculated by comparing the maximum document}
{width to the width of the viewRect. The current values are set by comparing the offset between}
{the view and destination rects. If necessary and we canRedraw, have the control be re-drawn by}
{calling ShowControl.}
        var
            max: integer;
            oldValue, oldMax: integer;
            cliprgn: RgnHandle;
            r: Rect;
            viswidth: integer;
    begin
        oldValue := GetControlValue(hcontrol);
        oldMax := GetControlMaximum(hcontrol);
        GetDItemRect(window, list_item, r);
        max := list_width - (r.right - 16 - r.left);
        if max < 0 then begin
            max := 0;            {check for negative values}
        end;
        list_offset := Pin(0, oldValue, max);
        SetPort(window);
        cliprgn := NewRgn;
        GetClip(cliprgn);
        SetRect(r, 0, 0, 0, 0);
        ClipRect(r);
        SetControlMaximum(hcontrol, max);
        SetClip(cliprgn);
        DisposeRgn(cliprgn);
        SetControlValue(hcontrol, list_offset);
        viswidth := list^^.rView.right - list^^.rView.left;
        SetSmartScrollInfo( hcontrol, viswidth, max + viswidth );
        if canRedraw and ((max <> oldMax) or (list_offset <> oldValue)) then begin
            ShowControl(hcontrol);            {check to see if the control can be re-drawn}
        end;
    end;

    procedure ListWindowObject.CreateList (font, size: integer; listitem: integer; ldefID: integer; hscroll: boolean);
        var
            view, bounds: Rect;
            siz: Point;
            fi: FontInfo;
            dr: Rect;
    begin
        AssertDidStartup( startup_check );
        list_item := listitem;
        handle_shift_tab := false;
        never_drag := true;
        typed_time := 0;
        max_display_width := maxInt;
        header_height := 0;
        SetPort(window);
        TextFont(font);
        TextSize(size);
        GetFontInfo(fi);
        draw_grow_icon := true;
        GetDItemRect( window, list_item, view );
        HandleAllUserItems;
        SetRect(bounds, 0, 0, 1, 0);
        view.right := view.right - 15;
        SetPt(siz, 30000, fi.ascent + fi.descent + fi.leading);
        list := LNew(view, bounds, siz, ldefID, window, true, true, false, true);
        list^^.refCon := longint(gCallLDEFProc);
        if hscroll then begin
            SetRect(dr, 0, 0, 100, 16);
            hcontrol := NewControl(window, dr, '', true, 0, 0, 0, scrollBarProc, 0);
        end else begin
            hcontrol := nil;
        end;
        Resize;
    end;

    procedure ListWindowObject.Destroy;
    begin
        LDispose(list);
        inherited Destroy;
    end;

    procedure ListWindowObject.DoDoubleClickCell (c: Cell);
    begin
{$unused(c)}
    end;

    function ListWindowObject.DoSetupDragCell (c: Cell; dragref: DragReference; dragrgn: RgnHandle): OSErr;
    begin
{$unused(c, dragref, dragrgn)}
        DoSetupDragCell := -1;
    end;

    function ListWindowObject.DoSetupDrag (dragref: DragReference; dragrgn: RgnHandle): OSErr;
        var
            c: Cell;
            err: OSErr;
    begin
        err := -23;
        c.h := 0;
        c.v := 0;
        while LGetSelect(true, c, list) do begin
            err := DoSetupDragCell(c, dragref, dragrgn);
            if err <> noErr then begin
                leave;
            end;
            c.v := c.v + 1;
            c.h := 0;
        end;
        DoSetupDrag := err;
    end;

    type
        ClickLoopData = record
            first_call: boolean;
            first_point: Point;
            er: EventRecord;
            wobj: WObject;
        end;
        ClickLoopDataPtr = ^ClickLoopData;

    function MyClickLoop( list: ListHandle; data: ClickLoopDataPtr ) : boolean;
        var
            r, cellRect: Rect;
            cellClicked: Cell;
            curPt: Point;
            dummy: boolean;
            ret: boolean;
    begin
        ret := true;
        if data^.first_call then begin
            data^.first_call := false;
            GetMouse(data^.first_point);
        end else begin
            SetRect(r, data^.first_point.h - 3, data^.first_point.v - 3, data^.first_point.h + 3, data^.first_point.v + 3);
            cellClicked := LLastClick(list);
            LRect(cellRect, cellClicked, list);
            dummy := SectRect(r, cellRect, r);
            GetMouse(curPt);
            if not PtInRect(curPt, r) then begin
                data^.wobj.DoTrackDrag(data^.er);
                ret := false;
            end;
        end;
        MyClickLoop := ret;
    end;

    function ListWindowObject.DontDrag (er: EventRecord): boolean;
    begin
{$unused(er)}
        DontDrag := never_drag or last_event_had_shift or last_event_had_command;
    end;

    function ListWindowObject.DoLClick (er: EventRecord): boolean;
        var
            double: boolean;
            local: Point;
            data: ClickLoopData;
    begin
        local := er.where;
        GlobalToLocal(local);
        if not has_DragManager or DontDrag(er) then begin
            CursorSetProcessing(false);
            double := LClick(local, er.modifiers, list);
        end else begin
            data.first_call := true;
            data.er := er;
            data.wobj := self;
            CursorSetProcessing(false);
            double := LClickSafe(local, er.modifiers, list, MyClickLoop, @data);
        end;
        DoLClick := double;
    end;

    procedure ListWindowObject.OpenParent;
    begin
    end;

    procedure ListWindowObject.SetSingleSelection (v: integer);
    begin
        LUpdate(WindowPeek(window)^.updateRgn, list);
        LSetSingleSelection(list, v);
        LAutoScroll(list);
    end;

    procedure ListWindowObject.DoDoubleClick;
        var
            c: Cell;
    begin
        c.h := 0;
        c.v := 0;
        while LGetSelect(true, c, list) do begin
            DoDoubleClickCell(c);
            c.v := c.v + 1;
            c.h := 0;
        end;
    end;

    var
        action_listobj: ListWindowObject;

    procedure CommonAction (control: ControlHandle; var amount: integer);
        var
            value, max, ovalue: integer;
    begin
        value := GetControlValue(control);
        ovalue := value;
        max := GetControlMaximum(control);
        value := Pin(0, value - amount, max);
        if value <> ovalue then begin
            SetControlValue(control, value);
        end;
        amount := ovalue - value;   { calculate true change }
    end; { CommonAction  }

{ Determines how much to change the value of the horizontal scrollbar by and how }
{ much to scroll the TE record. }
    procedure HAction (control: ControlHandle; part: integer);
        var
            amount: integer;
            window: WindowPtr;
    begin
        if (part <> 0) then begin
            window := action_listobj.window;
            case part of
                kControlUpButtonPart, kControlDownButtonPart:    begin    { a few pixels }
                    amount := 8;
                end;
                kControlPageUpPart, kControlPageDownPart: begin        { a page width }
                    with action_listobj.list^^.rView do begin
                        amount := (right - left);
                    end;
                end;
            end;
            if ((part = kControlDownButtonPart) or (part = kControlPageDownPart)) then begin
                amount := -amount;        { reverse direction }
            end;
            CommonAction(control, amount);
            if amount <> 0 then begin
                action_listobj.list_offset := GetControlValue(control);
                action_listobj.DrawUserItem( action_listobj.list_item);
            end;
        end;
    end;

    function ListWindowObject.GetEntryName (c: Cell): Str255;
    begin
{$unused(c)}
        GetEntryName := '';
    end;

    function ListWindowObject.GetUniqueEntryName (c: Cell): Str255;
    begin
        GetUniqueEntryName := concat(GetEntryName(c), chr(0), chr(c.v div 256), chr(c.v mod 256));
    end;

    function ListWindowObject.SelectFirstAfter (s: Str255): boolean;
        var
            i, index: integer;
            c: Cell;
            best, n: Str255;
            good: boolean;
    begin
        good := false;
        best := concat(chr(255), chr(255));
        for i := 0 to LCount( list ) - 1 do begin
            c.h := 0;
            c.v := i;
            n := GetUniqueEntryName(c);
            if (IUCompString(s, n) < 0) & (IUCompString(n, best) < 0) then begin
                best := n;
                index := c.v;
                good := true;
            end;
        end;
        if good then begin
            SetSingleSelection(index);
        end;
        SelectFirstAfter := good;
    end;

    function ListWindowObject.SelectFirstBefore (s: Str255): boolean;
        var
            i, index: integer;
            c: Cell;
            best, n: Str255;
            good: boolean;
    begin
        good := false;
        index := 0;
        best := '';
        for i := 0 to LCount( list ) - 1 do begin
            c.h := 0;
            c.v := i;
            n := GetUniqueEntryName(c);
            if (IUCompString(s, n) > 0) & (IUCompString(n, best) > 0) then begin
                best := n;
                index := c.v;
                good := true;
            end;
        end;
        if good then begin
            SetSingleSelection(index);
        end;
        SelectFirstBefore := good;
    end;

    function ListWindowObject.GetFirstSelection (var c: Cell): boolean;
        var
            best, n: Str255;
            index: integer;
    begin
        GetFirstSelection := false;
        c.h := 0;
        c.v := 0;
        best := concat(chr(255), chr(255));
        while LGetSelect(true, c, list) do begin
            GetFirstSelection := true;
            n := GetUniqueEntryName(c);
            if IUCompString(n, best) < 0 then begin
                index := c.v;
            end;
            c.v := c.v + 1;
        end;
        c.h := 0;
        c.v := index;
    end;

    function ListWindowObject.GetLastSelection (var c: Cell): boolean;
        var
            best, n: Str255;
            index: integer;
    begin
        GetLastSelection := false;
        c.h := 0;
        c.v := 0;
        best := '';
        while LGetSelect(true, c, list) do begin
            GetLastSelection := true;
            n := GetUniqueEntryName(c);
            if IUCompString(n, best) > 0 then begin
                index := c.v;
            end;
            c.v := c.v + 1;
        end;
        c.h := 0;
        c.v := index;
    end;

    procedure ListWindowObject.DoKey (const er:EventRecord; ch: char);
        var
            c: Cell;
            index: integer;
            dummy: boolean;
            onlyoneselection: boolean;
    begin
{$unused(er)}
        onlyoneselection := BAND(list^^.selFlags, lOnlyOne) <> 0;
        if ch < ' ' then begin
            typed_time := 0;
        end;
        case ord(ch) of
            downArrowChar:  begin
                if last_event_had_command then begin
                    DoDoubleClick;
                end else begin
                    ObscureCursor;
                    if LCount( list ) > 0 then begin
                        if LGetLastSelection(list, c) then begin
                            index := c.v + 1;
                        end else begin
                            index := 0;
                        end;
                        if index >= LCount( list ) then begin
                            index := LCount( list ) - 1;
                        end;
                        if onlyoneselection or not last_event_had_shift then begin
                            SetSingleSelection(index);
                        end else begin
                            c.v := index;
                            LSetSelect(true, c, list);
                        end;
                    end;
                end;
            end;
            upArrowChar:  begin
                if last_event_had_command then begin
                    OpenParent;
                end else begin
                    ObscureCursor;
                    if LCount( list ) > 0 then begin
                        if not LGetFirstSelection(list, c) then begin
                            c.v := LCount( list );
                        end;
                        c.v := c.v - 1;
                        if c.v < 0 then begin
                            c.v := 0;
                        end;
                        if onlyoneselection or not last_event_had_shift then begin
                            SetSingleSelection(c.v);
                        end else begin
                            LSetSelect(true, c, list);
                        end;
                    end;
                end;
            end;
            homeChar:  begin
                ObscureCursor;
                LScroll(0, -LCount( list ), list);
            end;
            endChar:  begin
                ObscureCursor;
                LScroll(0, LCount( list ), list);
            end;
            pageUpChar:  begin
                ObscureCursor;
                LScroll(0, -(list^^.visible.bottom - list^^.visible.top - 2), list);
            end;
            pageDownChar:  begin
                ObscureCursor;
                LScroll(0, (list^^.visible.bottom - list^^.visible.top - 2), list);
            end;
            tabChar:  begin
                ObscureCursor;
                if last_event_had_shift then begin
                    if not GetFirstSelection(c) | not SelectFirstBefore(GetUniqueEntryName(c)) then begin
                        dummy := SelectFirstBefore(chr(255));
                    end;
                end else begin
                    if not GetLastSelection(c) | not SelectFirstAfter(GetUniqueEntryName(c)) then begin
                        dummy := SelectFirstAfter('');
                    end;
                end;
            end;
            3, 13:  begin
                DoDoubleClick;
            end;
            otherwise begin
                ObscureCursor;
                if ch >= ' ' then begin
                    if last_event_time - typed_time > 60 then begin
                        typed_chars := '';
                    end;
                    typed_time := last_event_time;
                    typed_chars := concat(typed_chars, ch);
                    if not SelectFirstAfter(typed_chars) then begin
                        dummy := SelectFirstBefore(chr(255));
                    end;
                end;
            end;
        end;
{ WARNING: self may have been destroyed! }
    end;

    procedure ListWindowObject.DoItemWhere (const er: EventRecord; item: integer);
        var
            didit: boolean;
            ctl: ControlHandle;
            part, value: integer;
            r: Rect;
            local: Point;
    begin
        if item = list_item then begin
            SetPort(window);
            local := er.where;
            GlobalToLocal(local);
            if local.v < header_height then begin
                GetDItemRect(window, list_item, r);
                r.bottom := r.top + header_height;
                DoHeaderClick(r, local, er);
            end else begin
                didit := false;
                if hcontrol <> nil then begin
                    part := FindControl(local, window, ctl);
                    if ctl = hcontrol then begin
                        didit := true;
                        if part = kControlIndicatorPart then begin
                            value := GetControlValue(hcontrol);
                            part := TrackControl(hcontrol, local, nil);
                            if part <> 0 then begin
                                list_offset := GetControlValue(hcontrol);
                                if value <> list_offset then begin
                                    InvalRect(window^.portRect);
                                end;
                            end;
                        end else begin
                            action_listobj := self;
                            value := TrackControl(hcontrol, local, gHActionProc);
                        end;

                    end;
                end;
                if not didit & DoLClick(er) then begin
                    DoDoubleClick;
                end;
            end;
        end else begin
            inherited DoItemWhere(er, item);
        end;
    end;

    procedure ListWindowObject.DoActivateDeactivate (activate: boolean);
    begin
        LActivate(activate, list);
        if hcontrol <> nil then begin
            if activate then begin
                ShowControl(hcontrol);
            end else begin
                HideControl(hcontrol);
            end;
        end;
        inherited DoActivateDeactivate(activate);
    end;

    procedure ListWindowObject.Resize;
        const
            invis = 0;
            vis = 255;
        var
            r: Rect;
            width, height, nheight, lineheight: integer;
    begin
        SetPort(window);
        lineheight := list^^.cellSize.v;
        width := window^.portRect.right - window^.portRect.left;
        height := window^.portRect.bottom - window^.portRect.top;
        nheight := (height - header_height - 16) mod lineheight;
        if nheight <> 0 then begin
            SizeWindow(window, width, height - nheight, false);
        end;
        growRect.top := (50 + lineheight - 1) div lineheight * lineheight + header_height + 16;
        r.left := 0;
        r.right := window^.portRect.right + 1;
        if r.right > max_display_width then begin
            r.right := max_display_width;
        end;
        r.top := 0;
        r.bottom := window^.portRect.bottom;
        SetDItemRect(window, list_item, r);
        r.top := r.top + Choose( header_height > 0, header_height + 1, 0);
        r.bottom := r.bottom - 15;
        height := r.bottom - r.top;
        list^^.rView.topLeft := r.topLeft; { LMove???? }
        LSize(r.right - r.left - 16, height, list);
        if hcontrol <> nil then begin
            hcontrol^^.contrlVis := invis;
            MoveControl(hcontrol, r.left, r.bottom);
            SizeControl(hcontrol, r.right - r.left - 15, 16);
            AdjustHContol(false);
            hcontrol^^.contrlVis := vis;
        end;
        UpdateZoomHeight;
        InvalRect(window^.portRect);
        inherited Resize;
    end;

    procedure ListWindowObject.DrawGrow;
        var
            r: Rect;
    begin
        SetRect(r, -30000, header_height + 1, 30000, 30000);
        DrawTheFriggingGrowIcon(window, r);
    end;

    function ListWindowObject.CountSelections: integer;
    begin
        CountSelections := LCountSelections(list);
    end;

    function ListWindowObject.IsSelection: boolean;
    begin
        IsSelection := LHasSelection(list);
    end;

    procedure ListWindowObject.RedrawLine( line: integer );
        var
            c: Cell;
    begin
        c.v := line;
        c.h := 0;
        LDraw( c, list );
    end;

    function InitMyListWindow(var msg: integer): OSStatus;
    begin
{$unused(msg)}
        DidStartup( startup_check );
        DidStartup( startup_check );
        gCallLDEFProc := NewListDefProc(CallLDEF);
        gHActionProc := NewControlActionProc(HAction);
        InitMyListWindow := noErr;
    end;

    procedure StartupMyListWindow;
    begin
        StartupDialogs;
        SetStartup( InitMyListWindow, nil, 0, nil );
    end;

end.
    function MyClickLoop: boolean; { returns the bloody equal flag for gods sake! }
    begin
        MyClickLoop := MyClickLoop2; { BE VERY CAREFUL!  Returns the equal flag! }
    end;